home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…stman Always Clicks Twice / ADC Developer CD (1993-01) (''The Postman Always Clicks Twice'')_iso / Dev.CD 199301.iso / Development Platforms / LISP Related / LISP Goodies / matt's utils 8sept / cl.lisp next >
Encoding:
Text File  |  1992-08-03  |  7.1 KB  |  174 lines  |  [TEXT/CCL2]
  1. ;;;
  2. ;;; cl.lisp
  3. ;;;
  4.  
  5. #|
  6. ================================================================
  7. Purpose ========================================================
  8. ================================================================
  9. Defines a simple compile and load function. (OK not so simple any more!)
  10.  
  11.  
  12. ================================================================
  13. Status =========================================================
  14. ================================================================
  15. Released.
  16.  
  17. Copyright © 1990-92 Chris Eliot. All Rights Reserved. Send
  18. bugs, comments, questions, and fixes to eliot@cs.umass.edu.
  19.  
  20. ================================================================
  21. Change history =================================================
  22. ================================================================
  23. 3-Aug-92 mc    Created this header, commented out cl form at bottom, and added
  24.          the call to provide.
  25.  
  26. |#
  27.  
  28.  
  29. (in-package "COMMON-LISP-USER")
  30.  
  31.  
  32. ;;; Default value of compile switch.
  33. (defvar *force-compile* nil)
  34.  
  35. ;;; Default directory for binary files.
  36. (defvar *binary-file-directory* nil)
  37.  
  38. ;;; Default list of files to check for assumed macros. It is assumed that
  39. ;;; all files depend upon macros in these files and must be recompiled if
  40. ;;; any file in this list is changed.
  41. (defvar *default-compile-after-files* nil)
  42.  
  43. (defvar *binary-file-type* "FASL")      ; Implementation dependent type for
  44.                                         ; compiled files.
  45.  
  46. ;;; Compile and load a file.
  47.  
  48. ;;;    file is the file to compile (if needed) and load.  The file name should
  49. ;;;be specified without a type.
  50.  
  51. ;;;    compile-p forces a compile even if it is otherwise not thought to be
  52. ;;;needed (unless the source is missing.)
  53.  
  54. ;;;    load-p can have values, T, NIL or :IF-CHANGED. The default (T) forces
  55. ;;;the binary (if available) or source (if binary not available) to be
  56. ;;;loaded.  NIL prevents loading entirely and is used to simple ensure that
  57. ;;;the file has been compiled.  :IF-CHANGED causes the file to be loaded
  58. ;;;only if is needs to be recompiled.  This is used when a system has
  59. ;;;already been loaded and only new changes need reloading.
  60.  
  61. ;;;    after is a list of files that are assumed to contain macros used by
  62. ;;;this source file. CL will ensure that this file is compiled after all
  63. ;;;files in the 'after' list.
  64.  
  65. ;;;    binary is the directory in which to put the binary file. Specify this
  66. ;;;argument if you want to keep the compiled versions of files in a
  67. ;;;different place from the source.
  68.  
  69. ;;; This function can also be used for binary only files or files that
  70. ;;; should not be compiled, but specifying NIL for the compile-p argument.
  71.  
  72. (defun cl (file &key
  73.                 (compile-p *force-compile*)
  74.                 (load-p t)
  75.                 (after *default-compile-after-files*)
  76.                 (binary *binary-file-directory*))
  77.   (with-simple-restart
  78.     (error "Skip CL ~s" file)
  79.     ;; Merge pathnames to create the full pathnames for the source and
  80.     ;; binary files.  Use the (user-homedir-pathname) to first create a
  81.     ;; base name and then merge in the correct types.
  82.     (let* ((base-name (merge-pathnames file (user-homedir-pathname)))
  83.            (binary-name (make-pathname 
  84.                          :type *binary-file-type*
  85.                          :defaults (if binary 
  86.                                      (merge-pathnames binary base-name)
  87.                                      base-name))
  88.                         )
  89.            (source (make-pathname
  90.                     :type "LISP"
  91.                     :defaults base-name)))
  92.       ;; We can't cope with the situation where neither a source or a
  93.       ;; binary exist. Check for this and bomb.
  94.       (when (and (null (probe-file source))
  95.                  (null (probe-file binary-name)))
  96.         (error "No source or binary for ~s" file))
  97.       
  98.       ;; Analyze the arguments and file write dates to determine if a
  99.       ;; compile is needed.
  100.       (cond ((null (probe-file source))
  101.              ;; No source found - Will warn about this when loading.
  102.              (setq source nil)
  103.              (setq compile-p nil))
  104.             ((not (null compile-p)) #| Force compile |#)
  105.             ((or (not (probe-file binary-name))
  106.                  (> (file-write-date source)
  107.                     (file-write-date binary-name)))
  108.              ;; Source has changed - for new compile.
  109.              (setq compile-p t))
  110.  
  111.             ;; Finally, check all of the dependency files for one with a
  112.             ;; later compile date.
  113.             ((loop for other-file in after
  114.                    for other-source =
  115.                    (make-pathname :type "LISP"
  116.                                   :defaults
  117.                                   (merge-pathnames other-file
  118.                                                    (user-homedir-pathname)))
  119.                    for other-binary =
  120.                    (make-pathname :type *binary-file-type*
  121.                                   :defaults
  122.                                   (merge-pathnames other-file (user-homedir-pathname)))
  123.                    ;; Check for a dependency file with a change or compile later
  124.                    ;; than the current file's compile date.                 
  125.                    thereis (or (and (probe-file other-binary)
  126.                                     (> (file-write-date other-binary)
  127.                                        (file-write-date binary-name)))
  128.                                (and (probe-file other-source)
  129.                                     (> (file-write-date other-source)
  130.                                        (file-write-date binary-name)))))
  131.              (setq compile-p t))
  132.             )
  133.       
  134.       ;; We have determined if a compile is needed; do it and determine if
  135.       ;; loading is needed.
  136.       (cond ((null compile-p)
  137.              (when (eql load-p :if-changed)
  138.                (setq load-p nil)))
  139.             (t (format t "~&; Compiling ~s into ~s" source binary-name)
  140.                ;; Note: Skip & Retry compiling are already available in CCL, so
  141.                ;; this is not needed.  Skip and retry Loading needs to be
  142.                ;; implemented at this level.
  143.                (with-simple-restart
  144.                  (error "Skip Compiling ~s" source)
  145.                  (let ((ok nil))
  146.                    ;; Loop until compile is successful or user aborts.
  147.                    (loop while (null ok)
  148.                          do (with-simple-restart
  149.                               (error "Retry Compiling ~s" source)
  150.                               (compile-file source :output-file binary-name)
  151.                               (setq ok t)))))))
  152.       (when load-p
  153.         (with-simple-restart
  154.           (error "Skip Loading ~s" binary-name)
  155.           (let ((ok nil))
  156.             ;; Loop until load is successful or user aborts.
  157.             (loop while (null ok)
  158.                   do (with-simple-restart
  159.                        (error "Retry Loading ~s" binary-name)
  160.                        (load binary-name)
  161.                        (if source 
  162.                          (format t "~&  From source ~s" source)
  163.                          (format t "*** No Source Available ***"))
  164.                        (setq ok t)))))
  165.         )))
  166.   )
  167.  
  168.  
  169. (provide "CL")
  170.  
  171.  
  172. #|
  173. (cl #p"HAT:AUX;cl" :after nil :load-p :if-changed :binary nil)
  174. |#